COMMENT ⊗   VALID 00006 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	entry
C00009 00003	! 	record class declarations: scalar,vector,rot,trans,frame,new_tree,expr
C00012 00004	!	compute_func,uncompute_func,error,ggtoken
C00015 00005	!	arithcode,makecode 
C00024 00006	!	procedures exp,term,factor,GTEXPR
C00045 ENDMK
C⊗;
entry;
BEGIN "GTEXPR"
EXTERNAL STRING TOKEN;

	REQUIRE "[][]" DELIMITERS;
	DEFINE	RPTR	= [RECORD_POINTER],
		RCLASS	= [RECORD_CLASS],
		CRLF	= [('15&'12)],
		$AL$	= [FALSE],
		$POINTY$	= [TRUE],
		SPACE	= [" "],
		NUMERIC_TYPE	= [(2)],
		!	= [COMMENT],
		α	= [BEGIN],
		β	= [END];

!	DEFINE	ID_TYPE	= [(1)];
				define
preload_array(name, defs, type, first, len)=[
	preload_with defs null; type array name[first:first+len] ];

				define
preset_array(name, defs, type, first, len)=[
	preset_with defs null; type array name[first:first+len] ];

				define

indices(name, postfix)=[
    redefine xxcount=1;
    redefine xx(xxarg)=[
	redefine xxtemp= [ define xxarg]&[postfix=xxcount];
	xxtemp;
	redefine xxcount=xxcount+1;];
    name ];

	define op_list=[
ZZ("*",	times,	#TERM)
ZZ(".",	dot,		#TERM)
ZZ("REL",	rel,		#TERM)
ZZ("←",	backarrow,	#TERM)
ZZ("/",	divide,	#TERM)
ZZ("+",	Plus,	#EXP)
ZZ("-",	minus,	#EXP)
ZZ("WRT",	WRT,		#TERM)

ZZ("POS",	POS,		#FACTOR)
ZZ("UNIT",	UNIT,	#FACTOR)
ZZ("AXIS",AXIS,	#FACTOR)
ZZ("ORIENT",	ORIENT,	#FACTOR)
ZZ("CONSTRUCT",	CONSTRUCT,	#FACTOR)
ZZ("FRAME",	FRAME,	#FACTOR)
ZZ("VECTOR",	VECTOR,	#FACTOR)
ZZ("TRANS",	TRANS,	#FACTOR)
ZZ("|",	MAGNITUDE,	#FACTOR)
ZZ(["("],	LPAREN,	#FACTOR)
ZZ(["( , , )"],IMPLICIT,	#FACTOR)
ZZ("ROT",	ROT,		#FACTOR)
];

REDEFINE ZZ(ARG0,ARG1,ARG2)=[XX(ARG1)];

indices(op_list,_X);


DEFINE #EXP=1,#FACTOR=2,#TERM=3;

REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG0,];
preset_array(CODE_OP, OP_LIST,STRING, 1, ROT_X);

REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG2,];
preset_ARRAY(TCODE,OP_LIST,INTEGER,1,ROT_X);

DEFINE #SC=1,#VT=2,#RT=3,#TR=4,#FR=5,#DTYPE=6;

PREset_WITH NULL,"SCALAR","VECTOR","ROT","TRANS","FRAME";
STRING ARRAY $DTYPE[0:5];


DEFINE 		ID_TYPE = 1,
		INT_TYPE = 2,
		REAL_TYPE =  3,
		OPERATOR_TYPE = 4,
		RES_TYPE = 5,
		UNDECLARED_TYPE = 0;
FORWARD INTEGER TOKEN_CLASS;

integer procedure decode_op(STRING OP);
α INTEGER Q;
	CASE OP OF
		α
			["+"]	Q←PLUS_X;
			["("]	Q←LPAREN_X;
			["|"]	Q←MAGNITUDE_X;
			["-"]	Q←MINUS_X;
			["*"]	Q←TIMES_X;
			["/"]	Q←DIVIDE_X;
			["→"]	Q←BACKARROW_X;
			["."]	Q←DOT_X;

		ELSE IF EQU(OP,"REL") THEN Q←REL_X
		ELSE IF EQU(OP,"WRT") THEN Q←WRT_X
		ELSE IF EQU(OP,"POS") THEN Q←POS_X
		ELSE IF EQU(OP,"UNIT") THEN Q←UNIT_X
		ELSE IF EQU(OP,"AXIS") THEN Q←AXIS_X
		ELSE IF EQU(OP,"ORIENT") THEN Q←ORIENT_X
		ELSE IF EQU(OP,"CONSTRUCT") THEN Q←CONSTRUCT_X
		ELSE IF EQU(OP,"FRAME") THEN Q←FRAME_X
		ELSE IF EQU(OP,"VECTOR") THEN Q←VECTOR_X
		ELSE IF EQU(OP,"TRANS") THEN Q←TRANS_X
		ELSE IF EQU(OP,"ROT") THEN Q←ROT_X
		ELSE Q←0

		β;
	TOKEN_CLASS←IF Q=0 THEN 0 ELSE TCODE[Q];
RETURN(Q);
β;
! 	record class declarations: scalar,vector,rot,trans,frame,new_tree,expr;
EXTERNAL RCLASS SCALAR (REAL VALUE);
		! value=value of the scalar;

EXTERNAL RCLASS VECTOR (REAL XC,YC,ZC);
		! xc,yc,zc=value of the component of the vector along x,y,z axis;

EXTERNAL RCLASS FRAME (STRING PNAME; RPTR (FRAME) DAD,SON,EBRO,YBRO; INTEGER HOWLINKED;
              REAL ARRAY XF);
		! pname=pname of the frame;
		! dad,son,ebro,ybro=pointers to dad,son,elder and younger brother
		  in frame tree;
		! howlinked=kind of affixment(rigid,nonrigid,independent);
		! xf=array of values
		  xf[1:3,1:3]=rotation matrix,
		  xf[1:3,4]=translation vector,
		  xf[4,1:3]=0,
		  xf[4,4]=1,
		  xf[5,1:3]=rotation angles,
		  xf[5,4]>0 if angles are valid;

EXTERNAL RCLASS ROT (REAL ARRAY XF);
		! xf=array of values (as for frame class);

EXTERNAL RCLASS TRANS(REAL ARRAY XF);
		! xf=array of values (as for frame class);
		! records not entered in $YMTAB, used for computations;
INTERNAL RCLASS TREE(RPTR(SCALAR,VECTOR,TRANS,ROT,FRAME)DATA; INTEGER DTYPE);

RCLASS EXPR ( RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME)PTR; INTEGER TYPE; RPTR(EXPR)NEXT);


RPTR (EXPR) PROCEDURE MK_EXPR(RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME) PTR; INTEGER TYPE);
	α RPTR(EXPR)X;		X←NEW_RECORD(EXPR);
	EXPR:PTR[X]←PTR;	EXPR:TYPE[X]←TYPE;
	RETURN(X);
	β;



INTERNAL RPTR(TREE)PROCEDURE NWTREE(RPTR(SCALAR, VECTOR,ROT,TRANS,FRAME) R; INTEGER T);
	α RPTR(TREE) K; K←NEW_RECORD(TREE);
	TREE:DATA[K]←R; TREE:DTYPE[K]←T; RETURN(K); β;

REQUIRE "EXPINT.HDR[PNT,HE]" SOURCE_FILE;
!	compute_func,uncompute_func,error,ggtoken;


EXTERNAL PROCEDURE GTOKEN(BOOLEAN AGAIN(TRUE));
EXTERNAL INTEGER #TOKEN;
EXTERNAL BOOLEAN STOKEN;
EXTERNAL PROCEDURE ERROR(STRING S1,S2(NULL));


INTEGER PROCEDURE COMPUTE_FUNC(INTEGER I1,I2,I3,I4,I5);
	RETURN(((((I1*#DTYPE +I2)*#DTYPE + I3)*#DTYPE) + I4)*#DTYPE +I5);

INTEGER PROCEDURE UNCOMPUTE_FUNC(INTEGER I1,I2);
	α INTEGER I;
		CASE I2 OF
			α	[1]	I←I1 DIV #DTYPE↑4;
				[2]	I←(I1 DIV #DTYPE↑3)MOD #DTYPE;
				[3]	I←(I1 DIV #DTYPE↑2) MOD #DTYPE;
				[4]	I←(I1 DIV #DTYPE) MOD #DTYPE;
				[5]	I←I1 MOD #DTYPE;
				ELSE ERROR("WRONG FIELD IN UNCOMPPUTE_FUNC PARSER ERROR")
			β;
	RETURN(I);
	β;

INTEGER TOKEN_INDEX;
RPTR(SCALAR,VECTOR,ROT,TRANS,FRAME) TOKEN_PTR;

PROCEDURE GGTOKEN(BOOLEAN FLAG(TRUE));
α	RPTR(TREE)T1; GTOKEN(FLAG);
	CASE #TOKEN OF
	α
	[ID_TYPE]	α T1←DCDSYM(TOKEN);
			TOKEN_INDEX←TREE:DTYPE[T1];TOKEN_PTR←TREE:DATA[T1];
			β;
	[INT_TYPE]
	[REAL_TYPE]
			α INTEGER I; 
			TOKEN_INDEX←#SC;
			SCALAR:VALUE[TOKEN_PTR←NEW_RECORD(SCALAR)]←REALSCAN(TOKEN,I);
			β;
	[UNDECLARED_TYPE] TOKEN_INDEX←0;
	[RES_TYPE]	TOKEN_INDEX←DECODE_OP(TOKEN);
	[OPERATOR_TYPE]	TOKEN_INDEX←DECODE_OP(TOKEN)

	β;
β;
!	arithcode,makecode ;

REQUIRE "⊂⊃⊂⊃" REPLACE_DELIMITERS;
INTEGER PROCEDURE MATINX(INTEGER VAL; INTEGER ARRAY A; INTEGER LB,UB);
	α INTEGER L,M,U;
	L←LB; U←UB;
	DO α M←(U+L)/2;
		IF A[M]=VAL THEN RETURN(M)
			ELSE IF A[M]>VAL THEN U←M-1
			ELSE L←M+1;
	   β UNTIL L>U;
	RETURN(0);
	β;




DEFINE OPCODE = ⊂
XX("*",	TIMES_X,	#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"*")⊃)
XX("*",	TIMES_X,	#SC,	#VT,	#VT,	⊂OPSCVT(#1,#2,"*")⊃)
XX("*",	TIMES_X,	#VT,	#SC,	#VT,	⊂OPSCVT(#2,#1,"*")⊃)
XX("*",	TIMES_X,	#RT,	#VT,	#VT,	⊂OPRTVT(#1,#2)⊃)
XX("*",	TIMES_X,	#RT,	#RT,	#RT,	⊂OPRTRT(#1,#2)⊃)
XX("*",	TIMES_X,	#TR,	#VT,	#VT,	⊂OPTRVT(#1,#2)⊃)
XX("*",	TIMES_X,	#TR,	#TR,	#TR,	⊂OPTRTR(#1,#2)⊃)
XX("*",	TIMES_X,	#TR,	#FR,	#FR,	⊂OPTRFR(#1,#2)⊃)
XX("*",	TIMES_X,	#FR,	#FR,	#FR,	⊂OPFR(#1,#2)⊃)

XX(".",	DOT_X,		#VT,	#VT,	#SC,	⊂OPDOT(#1,#2)⊃)

XX("REL",	REL_X,	#VT,	#FR,	#VT,	⊂OPVTFR(#2,#1)⊃)

XX("→",	BACKARROW_X,	#FR,	#FR,	#TR,	⊂OPFRFR(#1,#2)⊃)

XX("/",	DIVIDE_X,	#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"/")⊃)
XX("/",	DIVIDE_X,	#VT,	#SC,	#VT,	⊂OPSCVT(#2,#1,"/")⊃)

XX("+",	PLUS_X,		#SC,	0,	#SC,	⊂OPSCAL(#1,NEW_RECORD(SCALAR),"+")⊃)
XX("+",	PLUS_X,		#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"+")⊃)
XX("+",	PLUS_X,		#VT,	0,	#VT,	⊂OPVET(#1,NEW_RECORD(VECTOR),"+")⊃)
XX("+",	PLUS_X,		#VT,	#VT,	#VT,	⊂OPVET(#1,#2,"+")⊃)
XX("+",	PLUS_X,		#VT,	#FR,	#FR,	⊂OPFRVT(#1,#2,"+")⊃)
XX("+",	PLUS_X,		#FR,	#VT,	#FR,	⊂OPFRVT(#2,#1,"+")⊃)

XX("-",	MINUS_X,	#SC,	0,	#SC,	⊂OPSCAL(NEW_RECORD(SCALAR),#1,"-")⊃)
XX("-",	MINUS_X,	#SC,	#SC,	#SC,	⊂OPSCAL(#1,#2,"-")⊃)
XX("-",	MINUS_X,	#VT,	0,	#VT,	⊂OPVET(NEW_RECORD(VECTOR),#1,"-")⊃)
XX("-",	MINUS_X,	#VT,	#VT,	#VT,	⊂OPVET(#1,#2,"-")⊃)
XX("-",	MINUS_X,	#FR,	#VT,	#FR,	⊂OPFRVT(#2,#1,"-")⊃)
! XX("WRT",	WRT_X,						) ;
YY("POS",	POS_X,		TPOS,	#VT,	1,	#TR,	0,	0)
YY("POS",	POS_X,		FPOS,	#VT,	1,	#FR,	0,	0)
YY("UNIT",	UNIT_X,		NORMVT,	#VT,	1,	#VT,	0,	0)
! YY("AXIS",	AXIS_X,		FAXIS,	#VT,	1,	#RT,	0,	0) ;
! YY("ORIENT",	ORIENT_X,	FORIENT,#RT,	1,	#TR,	0,	0) ;
! YY("REL",	REL_X,		RELVT,	#VT,	2,	#VT,	#FR,	0) ;
! YY("REL",	REL_X,		RELFR,	#FR,	2,	#FR,	#TR,	0) ;
! YY("WRT",	WRT_X,		WRTVT,	#VT,	2,	#VT,	#FR,	0) ;
YY("ORIENT",	ORIENT_X,	FORIEN,	#RT,	1,	#FR,	0,	0)
YY("CONSTRUCT",	CONSTRUCT_X,	CONSV,	#FR,	3,	#VT,	#VT,	#VT)
YY("CONSTRUCT",	CONSTRUCT_X,	CONSF,	#FR,	3,	#FR,	#FR,	#FR)
YY("FRAME",	FRAME_X,	FMAKE,	#FR,	2,	#RT,	#VT,	0) 
YY("VECTOR",	VECTOR_X,	VMAKE,	#VT,	3,	#SC,	#SC,	#SC)
YY("TRANS",	TRANS_X,	TMAKE,	#TR,	2,	#RT,	#VT,	0)
YY("MAGNITUDE",	MAGNITUDE_X,	SMOD,	#SC,	1,	#SC,	0,	0)
YY("MAGNITUDE",	MAGNITUDE_X,	VMOD,	#SC,	1,	#VT,	0,	0)
! YY("MAGNITUDE",	MAGNITUDE_X,	RMOD,	#SC,	1,	#RT,	0,	0) ;
YY("IMPLICIT",	IMPLICIT_X,	VMAKE,	#VT,	3,	#SC,	#SC,	#SC)
YY("IMPLICIT",	IMPLICIT_X,	RMAKE,	#RT,	2,	#VT,	#SC,	0)
YY("IMPLICIT",	IMPLICIT_X,	TMAKE,	#TR,	2,	#RT,	#VT,	0)
YY("ROT",	ROT_X,		RMAKE,	#RT,	2,	#VT,	#SC,	0)
⊃;
REDEFINE XXCOUNT=0;
redefine XX(OP,OP_TYPE,TYPE1,TYPE2,TYPE3,FUNC) = ⊂
	REDEFINE XXCOUNT=XXCOUNT+1;
	REDEFINE XX_VAL=((op_type*#dtype + type1)* #dtype + type2)*#DTYPE*#DTYPE;
	XX_VAL ,⊃;
redefine YY(OP,OP_TYPE,OP_FUNC,OP_DTYPE,#N,#1,#2,#3) = ⊂
	REDEFINE XXCOUNT=XXCOUNT+1;
	REDEFINE XX_VAL=(((op_type*#dtype + #1)* #dtype + #2)*#dtype + #3)*#DTYPE ;
	REDEFINE XX_TEMP=⊂XX_VAL ,⊃;
	XX_TEMP ⊃;

preset_array(OCODE, OPCODE, INTEGER, 1, XXCOUNT);

RPTR(EXPR) PROCEDURE MAKE_CODE(INTEGER $$$$, NARG; RPTR(EXPR)R1);
α	RPTR(EXPR)R3,x2; INTEGER PP,I; INTEGER ARRAY Q[1:4];
REDEFINE YY(OP,OP_TYPE,OP_FUNC,OP_DTYPE,#n,#1,#2,#3) = ⊂
	redefine xx_temp = ⊂
			   CASEC #n OFC
	⊂;R3←MK_EPXR(OP_FUNC,OP_DTYPE,NULL_RECORD)⊃,
	⊂;R3←MK_EXPR(OP_FUNC(EXPR:PTR[R1]),OP_DTYPE)⊃,
	⊂;R3←MK_EXPR(OP_FUNC(EXPR:PTR[R1],EXPR:PTR[EXPR:NEXT[R1]]),OP_DTYPE)⊃,
	⊂;R3←MK_EXPR(OP_FUNC(EXPR:PTR[R1],EXPR:PTR[EXPR:NEXT[R1]],
			   EXPR:PTR[EXPR:NEXT[EXPR:NEXT[R1]]]),OP_DTYPE)⊃,
			   ⊂;REQUIRE " HAH" MESSAGE;⊃ ENDC
			⊃;
	xx_temp ⊃;
REDEFINE XX(OP,OP_TYPE,TYPE1,TYPE2,TYPE3,FUNC) =
	⊂ 	redefine #1 = ⊂EXPR:PTR[R1]⊃  ;
		redefine #2 = ⊂EXPR:PTR[EXPR:NEXT[R1]]⊃ ;
	  redefine xx_temp = ⊂
		IFC (#SC≤TYPE3≤#FR) THENC
			; R3←MK_EXPR(FUNC,TYPE3)
		ELSEC	; REQUIRE " HAH " MESSAGE; ENDC ⊃;
	  xx_temp   ⊃;
	X2←R1;
	FOR I←1 STEP 1 UNTIL NARG MIN 4 DO 
		BEGIN Q[I]←EXPR:TYPE[X2]; X2←EXPR:NEXT[X2]; END;
	FOR I← NARG+1 MIN 5 STEP 1 UNTIL 4 DO Q[I]←0;

	PP←COMPUTE_FUNC($$$$,Q[1],Q[2],Q[3],Q[4]);
	I←MATINX(PP,OCODE,1,XXCOUNT);
	CASE I OF
	BEGIN
	ERROR(CODE_OP[$$$$]&" cannot take argument(s) type(s) "&
		$DTYPE[Q[1]]&"  "&$DTYPE[Q[2]]&"  "&$DTYPE[Q[3]]&"  "&$DTYPE[Q[4]])
	OPCODE
	END;
	return(R3);

β;
!	procedures exp,term,factor,GTEXPR;

!	E:	{+|-} T {+|- T }

	T:	F {*|/ F}

	F:	( E ), 
		f(  ,  ,  ...)
		<constant>,
		<id>,	;



! EXP	E:	{+|-} T {+|- T }

TERM	T:	F {*|/ F}

FACTOR	F:	( E ) or | E | or func(E,E,E,..) or <constant> or <id> ;


FORWARD RECURSIVE RPTR(EXPR)PROCEDURE TERM;
FORWARD RECURSIVE RPTR(EXPR)PROCEDURE FACTOR;


!	EXP	E:	{+|-} T {+|- T }	;

RECURSIVE RPTR(EXPR) PROCEDURE EXP;
	α	RPTR(EXPR) $$1; INTEGER I;
		IF #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS = #EXP THEN
			α I←TOKEN_INDEX;
			GGTOKEN;	$$1←TERM;
			$$1←MAKE_CODE(I,1,$$1);
			β
			ELSE $$1←TERM;
		WHILE #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS = #EXP DO
			α I←TOKEN_INDEX;
			GGTOKEN; EXPR:NEXT[$$1]←TERM;
			$$1←MAKE_CODE(I,2,$$1);
			β;
		RETURN($$1);
	β;

!	TERM	T:	F {*|/ F}	;

RECURSIVE RPTR(EXPR) PROCEDURE TERM;
	α	RPTR(EXPR) $$1; INTEGER I;
		$$1←FACTOR;
		WHILE  #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS = #TERM DO
			α I←TOKEN_INDEX;
			GGTOKEN; EXPR:NEXT[$$1]←FACTOR;
			$$1←MAKE_CODE(I,2,$$1);
			β;
		RETURN($$1);
	β;

RECURSIVE RPTR(EXPR) PROCEDURE FACTOR;
α	RPTR(EXPR)$$1,$$2,$$3; INTEGER I,I2;
		
	CASE #TOKEN OF
		α	
		[REAL_TYPE]	
		[INT_TYPE]	
			α
			$$1←MK_EXPR(TOKEN_PTR,TOKEN_INDEX);
			GGTOKEN(FALSE);
			β;

		[ID_TYPE]
			α
			$$1←MK_EXPR(TOKEN_PTR,TOKEN_INDEX);
			GGTOKEN(FALSE);
			β;

		[OPERATOR_TYPE]
			CASE TOKEN_INDEX OF
			α
			[LPAREN_X]
				α GGTOKEN; $$2←$$1←EXP; I2←1;
				IF TOKEN≠")"
				THEN WHILE TOKEN="," DO
					α GGTOKEN; $$3←EXP;
					I2←I2+1;
					$$2←(EXPR:NEXT[$$2]←$$3);
					β;
				IF TOKEN≠")" THEN
					ERROR("MISMATCHED PAREN,WILL INSERT")
					ELSE GGTOKEN(FALSE);
				IF I2≠1 THEN $$1←MAKE_CODE(IMPLICIT_X,I2,$$1);
				β;
			[MAGNITUDE_X]
				α GGTOKEN; $$1←EXP;
				IF TOKEN="|"
				THEN GGTOKEN(FALSE)
				ELSE ERROR("MISMATCHED VERT BAR, WILL INSERT");
				$$1←MAKE_CODE(MAGNITUDE_X,1,$$1);
				β;
			ELSE	ERROR("UNEXPECTED TOKEN FOUND"&TOKEN)
			β;
		[RES_TYPE]
			α I←TOKEN_INDEX; GGTOKEN;
			IF TOKEN≠"("
			THEN ERROR("REQUIRE LEFT PAREN, WILL INSERT")
			ELSE GGTOKEN;
			$$2←$$1←EXP; I2←1;
			WHILE TOKEN="," DO
				α GGTOKEN; $$3←EXP;	I2←I2 + 1;
				$$2←(EXPR:NEXT[$$2]←$$3);
				β;
			IF TOKEN≠")"
			    THEN ERROR("MISMATCHED PAREN, WILL INSERT")
			    ELSE GGTOKEN(FALSE);
			$$1←MAKE_CODE(I,I2,$$1);
			β;

		ELSE	ERROR("UNEXPECTED TOKEN FOUND")
				
		β;

	RETURN($$1);
β;


INTERNAL RPTR(TREE)PROCEDURE GTEXPR;
	α	RPTR(EXPR)$$1;
		GGTOKEN;
		$$1←EXP;
		STOKEN←TRUE;
		RETURN(NWTREE(EXPR:PTR[$$1],EXPR:TYPE[$$1]));
	β;

END;